home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 9 / litebar.zip / PROC.PRG < prev    next >
Text File  |  1991-08-08  |  73KB  |  1,846 lines
  1. *-- PROGRAM.....: PROC.PRG 
  2. *-------------------------------------------------------------------------------
  3. *-- Programmer..: Kenneth J. Mayer, (KENMAYER on ATBBS)
  4. *-- Date........: 07/07/1991
  5. *-- Notes.......: This is a procedure file I have been using for awhile,
  6. *--               modified for the dUFLP and dHUNG standards on the Ashton-
  7. *--               Tate Bulletin Board System (ATBBS). dUFLP is the dBASE Users
  8. *--               Function Library Project. dHUNG is the dBASE HUNGarian 
  9. *--               notation (a modified version of the HUNGARIAN programming
  10. *--               notation which can be found elsewhere on the ATBBS).
  11. *--
  12. *--               To use this procedure file in toto, the program must contain 
  13. *--               the line in it stating:
  14. *--                SET PROCEDURE TO PROC
  15. *--               To use any of the individual functions and/or procedures see 
  16. *--               the documentation for each function or procedure.
  17. *-- Rev. History: This has gone through so many revisions, some of it being
  18. *--               suggestions from users on ATBBS, and some in trying to set
  19. *--               it up for dUFLP, that it's too much to go into here ... <g>
  20. *--               Any procedures/functions here that were modified just for
  21. *--               the dHUNG/dUFLP notations show "None" for Rev. History ...
  22. *===============================================================================
  23.  
  24. PROCEDURE SetPrint
  25. *--------------------------------------------------------------------------
  26. *-- Programmer..: Ken Mayer (Kenmayer)
  27. *-- Date........: 05/24/1991
  28. *-- Notes.......: Used to set the the appropriate default settings. 
  29. *--               (Can be modified easily for other printers ...)
  30. *--               If you want "letter quality" print on some printers,
  31. *--               you can take the * out from the one line below. Note
  32. *--               that some printer drivers don't have a "letter quality" mode,
  33. *--               and dBASE will spit out an error message if you try to
  34. *--               force it (by using _pquality). I use this routine for
  35. *--               various systems, and only use _pquality for my dot matrix
  36. *--               at home. Change the printer driver below to the one you
  37. *--               are using.
  38. *-- Written for.: dBASE IV, 1.1
  39. *-- Rev. History: None
  40. *-- Calls.......: None
  41. *-- Called by...: Any
  42. *-- Usage.......: do setprint
  43. *-- Example.....: do setprint
  44. *-- Returns.....: None
  45. *-- Parameters..: None
  46. *--------------------------------------------------------------------------
  47.     _pdriver  = "HPLAS2I"  && printer driver
  48.     _ppitch   = "PICA"     && printer pitch (10 CPI)    
  49.     _box      = .t.          && make sure we can print boxes/line draw
  50.     _ploffset = 0          && page offset (left side) to 0
  51.     _lmargin  = 0          && left margin (also set to 0)
  52.     _rmargin  = 80         && right margin set to 80
  53.     _plength  = 66         && page length 
  54.     _peject   = "NONE"     && don't send extra blank pages . . .
  55.     * _pquality = .t.        && set print quality to high -- not available
  56.                              && for some printers
  57.     
  58. RETURN   
  59. *-- EoP: SetPrint
  60.  
  61. PROCEDURE PrintErr
  62. *--------------------------------------------------------------------------
  63. *-- Programmer..: Ken Mayer (Kenmayer)
  64. *-- Date........: 05/24/1991
  65. *-- Notes.......: Used to display a printer error for STAND-ALONE
  66. *--               systems. (The dBASE function PRINTSTATUS() doesn't work
  67. *--               on a Network with Print Spoolers ...)
  68. *-- Written for.: dBASE IV, 1.1
  69. *-- Rev. History: None
  70. *-- Calls.......: SHADOW               (procedure in proc.prg)
  71. *-- Called by...: Any
  72. *-- Usage.......: do printerr
  73. *-- Example.....: do setprint  && if it hasn't been done
  74. *--               if .not. printstatus()
  75. *--                  DO PRINTERR
  76. *--               endif
  77. *--               *    or
  78. *--               do while .not. printstatus() && my preference ... loop!
  79. *--                  DO PRINTERR
  80. *--               enddo
  81. *-- Returns.....: None
  82. *-- Parameters..: None
  83. *--------------------------------------------------------------------------
  84.  
  85.     if iscolor()    && if we're using a color monitor, use yellow on red
  86.         cColor = "RG+/R,RG+/R,RG+/R"
  87.     else            && otherwise, use black on white
  88.         cColor = "N/W,N/W,N/W"
  89.     endif
  90.     
  91.     define window wPErr from  7,15 to 16,57 double color &cColor
  92.     save screen to sPErr       && store current screen
  93.     do shadow with 7,15,16,57    && shadow box!
  94.     activate window wPErr      && here we go ..
  95.     
  96.     cCursor=set("CURSOR")      && save cursor setting
  97.     set cursor off             && turn cursor off
  98.                                && display message
  99.     do center with 0,40,"",chr(7) + "*** PRINTER ERROR ***"
  100.     do center with 2,40,""," The printer is not ready. Please check:"
  101.     do center with 3,40,"","1) that the printer is ON,        "
  102.     do center with 4,40,"","2) that the printer is ONLINE, and"
  103.     do center with 5,40,"","3) that the printer has paper.    "
  104.     do center with 7,40,"","Press any key to continue . . ."
  105.     
  106.     x=inkey(0)                 && wait for user to press a key ...
  107.     set cursor &cCursor        && set cursor to original setting ...
  108.     
  109.     deactivate window wPErr    && cleanup
  110.     release window wPErr
  111.     restore screen from sPErr
  112.     release screen sPErr
  113.     
  114. RETURN  
  115. *-- EoP: PrintErr
  116.  
  117. PROCEDURE SetColor
  118. *--------------------------------------------------------------------------
  119. *-- Programmer..: Phil Steele
  120. *-- Date........: 05/23/91
  121. *-- Notes.......: Used to set the screen colors for a system. It
  122. *--               checks to see if a color monitor is attached (ISCOLOR()),
  123. *--               and sets system variables, that can be used in SET COLOR OF
  124. *--               commands. You must define the memvars as PUBLIC, see Example
  125. *--               below -- otherwise nothing will work.
  126. *-- Written for.: dBASE IV, 1.1
  127. *-- Rev. History: Borrowed from Phil Steele's PCSDEMO (a public domain
  128. *--               program) and commented a bit more, minor modifications by
  129. *--               Ken Mayer (Kenmayer).
  130. *-- Calls.......: None
  131. *-- Called by...: Any
  132. *-- Usage.......: do setcolor
  133. *-- Example.....: in a menu or setup program:
  134. *--               PUBLIC cl_blank,cl_func,cl_help,cl_data,cl_error,;
  135. *--                      cl_entry,cl_stand,cl_menu,cl_warn 
  136. *--               DO setcolor
  137. *--                  by declaring the variables PUBLIC before calling SETCOLOR
  138. *--                  they should be globally available throughout, unless you
  139. *--                  use a CLEAR ALL or CLOSE ALL command ...
  140. *-- Returns.....: None
  141. *-- Parameters..: None
  142. *--------------------------------------------------------------------------
  143.     
  144.     if file("COLOR.MEM")
  145.         restore from Color.mem additive    && if color.mem exists, restore from it
  146.     else                                && otherwise, create it
  147.         lC           = iscolor()             && remember -- foreground/background
  148.         cl_Blank = "n/n,n/n,n"           && black on black on black ...
  149.         cl_Func  = "n/w"                 && function keys (used in CLRSHOW)
  150.             * if iscolor() = true, define color, otherwise black/white
  151.         cl_Help  = iif(lC,"n/g,g/n,n"      , "w+/n,n/w,n")   && help
  152.         cl_Data  = iif(lC,"rg+/gb,gb/rg,n" , "w+/n,n/w,n")   && data entry fields
  153.         cl_Error = iif(lC,"rg+/r,w/n,n"    , "w/n,n/w,n")    && error messages
  154.         cl_Entry = iif(lC,"n/w,w/n,n"      , "n/w,w/n,n")    && data entry??
  155.         cl_Stand = iif(lC,"w+/b,b/w,n"     , "w+/n,n/w,n")   && standard screen
  156.         cl_Menu  = iif(lC,"rg+/b,b/w,n"    , "w+/n,n/w,n")   && menus
  157.         cl_Warn  = iif(lC,"rg+/r,w/n,n"    , "w/n,n/w,n")    && warning messages
  158.         save to color all like cl_*        && create COLOR.MEM
  159.     endif
  160.     
  161.     *-- change current color settings to these ...
  162.     set color to &cl_stand    && default
  163.     set color of fields   to rg+/gb                && yellow/cyan
  164.     set color of messages to rg+/gb                && yellow/cyan
  165.     set color of box      to rg+/n                 && yellow/black
  166.     
  167. RETURN
  168. *-- EoP: SetColor
  169.  
  170. FUNCTION ExtrClr
  171. *--------------------------------------------------------------------------
  172. *-- Programmer..: Ken Mayer (Kenmayer)
  173. *-- Date........: 05/24/1991
  174. *-- Notes.......: Used to extract the first parameter of the MEMVARS
  175. *--               created from SETCOLOR above. The SET COLOR OF commands can
  176. *--               only use the first parameter.
  177. *--               It is recommended that you run SetColor (above) first, 
  178. *--               although if you define your own color memvars, this will work
  179. *--               just as well.
  180. *-- Written for.: dBASE IV, 1.1
  181. *-- Rev. History: None
  182. *-- Calls.......: None
  183. *-- Called by...: Any
  184. *-- Usage.......: extrclr(<cMemVar>)
  185. *-- Example.....: set color of highlight to &extrclr(cl_stand)
  186. *-- Returns.....: "W+/B"
  187. *-- Parameters..: cMemVar = color memory variable to have colors extracted from
  188. *--------------------------------------------------------------------------
  189.     
  190.     parameters cMemVar
  191.     
  192. RETURN substr(cMemVar,1,(at(",",cMemVar)-1)) 
  193. *-- EoF: ExtrClr
  194.  
  195. FUNCTION InvClr
  196. *--------------------------------------------------------------------------
  197. *-- Programmer..: Ken Mayer (Kenmayer)
  198. *-- Date........: 05/23/1991
  199. *-- Notes.......: Used to set an inverse color, using value(s) returned
  200. *--               from extrclr above, or from a single color memvar.
  201. *--               Inverted colors may give odd results -- RG+ (yellow) is
  202. *--               not a background color, for example, and will appear as
  203. *--               RG (brown) -- this may not be what you wanted ...
  204. *-- Written for.: dBASE IV, 1.1
  205. *-- Rev. History: None
  206. *-- Calls.......: None
  207. *-- Called by...: Any
  208. *-- Usage.......: invclr(<cMemVar>)
  209. *-- Example.....: set color of highlight to &invclr(extrclr(cl_stand))
  210. *--                    or
  211. *--               x = extrclr(cl_stand)
  212. *--               set color of highlight to &invclr(x)
  213. *-- Returns.....: "B/W+"
  214. *-- Parameters..: cMemVar = color variable containing colors to be inverted
  215. *--------------------------------------------------------------------------
  216.  
  217.     parameters cMemVar
  218.     
  219.         cTemp1 = substr(cMemVar,1,(at("/",cMemVar)-1))
  220.         cTemp2 = substr(cMemVar,(at("/",cMemVar)+1),len(cMemVar))
  221.  
  222. RETURN cTemp2+"/"+cTemp1
  223. *-- EoF: InvClr
  224.  
  225. PROCEDURE Open_Screen
  226. *--------------------------------------------------------------------------
  227. *-- Programmer..: Rick Price (Hammett)
  228. *-- Date........: 05/24/1991
  229. *-- Notes.......: Used to give a texture to the background of the screen
  230. *--               I got this from Rick when he uploaded it as part of his 
  231. *--               original entry to a Color Contest on the ATBBS. It is
  232. *--               kinda nice to have that texture on the screen, keeps it
  233. *--               from being monotonous.
  234. *-- Written for.: dBASE IV, 1.1
  235. *-- Rev. History: None
  236. *-- Calls.......: None
  237. *-- Called by...: Any
  238. *-- Usage.......: do open_screen
  239. *-- Example.....: do open_screen
  240. *-- Returns.....: None
  241. *-- Parameters..: None
  242. *--------------------------------------------------------------------------
  243.  
  244.     clear
  245.     nRow=0
  246.     cBackdrp = chr(176)  && chr(176) = "░", chr(177) = "▒", chr(178) = "▓"
  247.     do while nRow < 3
  248.        @nRow,0 to nRow+3,79 cBackdrp  && fill this section of the screen
  249.        nHoldRow = nRow
  250.        nRow = nRow + 6
  251.        @nRow,0 to nRow+3,79 cBackdrp
  252.        nRow = nRow + 6
  253.        @nRow,0 to nRow+3,79 cBackdrp
  254.        nRow = nRow + 6
  255.        @nRow,0 to nRow+3,79 cBackdrp
  256.        nRow = nHoldRow + 1
  257.     enddo
  258.     @24,0 to 24,79 cBackdrp
  259.  
  260. RETURN
  261. *-- EoP: OpenScreen
  262.  
  263. FUNCTION Do_Wait
  264. *--------------------------------------------------------------------------
  265. *-- Programmer..: Rick Price (Hammett)
  266. *-- Date........: 05/24/91
  267. *-- Notes.......: This function can replace the WAIT command with a message
  268. *--               in the usual Message line. This is useful for situations
  269. *--               where the user is used to messages at row 24 on the screen,
  270. *--               and this will handle it. It uses the default message of
  271. *--               "Press any key to continue ...", unless you pass your own
  272. *--               message to it. If you want the default, use nul (""), other-
  273. *--               wise dBASE will get annoyed.
  274. *-- Written for.: dBASE IV, 1.1
  275. *-- Rev. History: None
  276. *-- Calls.......: None
  277. *-- Called by...: Any
  278. *-- Usage.......: Do_Wait("<cMessage>")
  279. *-- Example.....: lc_wait = do_wait("message")
  280. *-- Returns.....: numeric value of key pressed by user to exit Wait (inkey())
  281. *-- Parameters..: cMessage = Message to display at bottom of screen
  282. *--------------------------------------------------------------------------
  283.  
  284.     parameters cMessage
  285.  
  286.     cWaitCur = set("CURSOR")    && save status of cursor
  287.     set cursor off
  288.     
  289.     ** If the passed parameter (message_to_display) is null, use a generic
  290.     ** message.
  291.     cMessage = ;
  292.     iif(""=cMessage," Press any key to continue . . . ",cMessage)
  293.     * center/truncate message
  294.     nMesLen = len(cMessage)   && get length of message
  295.     * if message length is greater than 80, truncate it to 80
  296.     cMessage = iif(nMesLen>80,LEFT(cMessage,80),cMessage)
  297.     nMesLen = len(cMessage)  && reset if message was longer than 80
  298.     * center message on row 24 of screen
  299.     @24,int((80-nMesLen)/2) say cMessage 
  300.     * return whatever key was pressed by user, in case you need it ...
  301.     cRetStr=chr(Inkey(0))
  302.     set cursor &cWaitCur  && reset cursor state to what it was before ...
  303.  
  304. RETURN cRetStr 
  305. *-- EoF: Do_Wait
  306.  
  307. PROCEDURE JazClear
  308. *--------------------------------------------------------------------------
  309. *-- Programmer..: Rick Price (Hammett)
  310. *-- Date........: 05/24/1991
  311. *-- Notes.......: Used to clear the screen from the middle out --
  312. *--               could be used with OpenScreen, above. I got this
  313. *--               from Rick at the same time I got the other two routines
  314. *--               above ...
  315. *-- Written for.: dBASE IV, 1.1
  316. *-- Rev. History: None
  317. *-- Calls.......: None
  318. *-- Called by...: Any
  319. *-- Usage.......: do jazclear
  320. *-- Examples....: do jazclear
  321. *-- Returns.....: None
  322. *-- Parameters..: None
  323. *--------------------------------------------------------------------------
  324.  
  325.     nWinR1 = 0     && row 1
  326.     nWinR2 = 24  && row 2
  327.     nWinC1 = 0   && column 1
  328.     nWinC2 = 79  && column 2
  329.     nStep = 1    && amount to increment by
  330.       * set starting point
  331.     mnWinC1 = int((nWinC2-nWinC1)/2)+nWinC1
  332.     mnWinC2 = mnWinC1+1
  333.     mnWinR1 = int((nWinR2-nWinR1)/2)+nWinR1
  334.     mnWinR2 = mnWinR1+1
  335.     
  336.     ** Adjust step offset values: nColOff & nRowOff
  337.     ** Vertical steps: nWinR1-nWinR1
  338.     nTmpAdjR = int((nWinR2 - nWinR1)/2)
  339.     nTmpAdjC = int((nWinC2 - nWinC1)/2)
  340.     
  341.     nAdjRow = ;
  342.     iif(nTmpAdjC > nTmpAdjR, nTmpAdjR/nTmpAdjC,1) * nStep
  343.     
  344.     nAdjCol = ;
  345.     iif(nTmpAdjR > nTmpAdjC, nTmpAdjC/nTmpAdjR,1) * nStep
  346.     
  347.     ncolleft = nWinC1
  348.     ncolrite = nWinC2
  349.     nRowTop = nWinR1
  350.     nRowBot = nWinR2
  351.     nWinC1 = mnWinC1
  352.     nWinC2 = mnWinC2
  353.     nWinR1 = mnWinR1
  354.     nWinR2 = mnWinR2
  355.     do while (nWinC1#nColLeft .or. nWinC2#nColRite .or. ;
  356.         nWinR1 # nRowTop .or. nWinR2 # nRowBot)
  357.         
  358.         * Adjust coordinates for the clear (moving out from the middle)
  359.         nWinR1 = ;
  360.         nWinR1-iif(nRowTop<nWinR1-nAdjRow,nAdjRow,nWinR1-nRowTop)
  361.         nWinR2 = ;
  362.         nWinR2+iif(nRowBot>nWinR2+nAdjRow,nAdjRow,nRowBot-nWinR2)
  363.         nWinC1 = ;
  364.         nWinC1-iif(nColLeft<nWinC1-nAdjCol,nAdjCol,nWinC1-nColLeft)
  365.         nWinC2 = ;
  366.         nWinC2+iif(nColRite>nWinC2+nAdjCol,nAdjCol,nColRite-nWinC2)
  367.         
  368.         * Perform the clear
  369.         @nWinR1,nWinC1 clear to nWinR2,nWinC2
  370.         @nWinR1,nWinC1 to nWinR2,nWinC2
  371.     enddo
  372.     clear
  373.     
  374. RETURN   
  375. *-- EoP: JazClear
  376.  
  377. PROCEDURE Center
  378. *--------------------------------------------------------------------------
  379. *-- Programmer..: Miriam Liskin
  380. *-- Date........: 05/24/1991
  381. *-- Notes.......: Centers text on the screen with @says
  382. *-- Written for.: dBASE IV, 1.1
  383. *-- Rev. History: This and all other procedures/functions listed in this
  384. *--               file attributed to Miriam Liskin came from "Liskin's
  385. *--               Programming dBASE IV Book". Very good, worth the money.
  386. *-- Calls.......: None
  387. *-- Called by...: Any
  388. *-- Usage.......: do center with <nLine>,<nWidth>,"<cColor>","<cText>"
  389. *-- Example.....: do center with 5,65,"RG+/GB","WARNING! This will blow up!"
  390. *--                  Note that the color field may be blank: ""
  391. *-- Returns.....: None
  392. *-- Parameters..: nLine  = Line or Row for @/Say
  393. *--               nWidth = Width of screen
  394. *--               cColor = Colors to be used ("Forg/Back") (may be nul "", in
  395. *--                           order to use the default colors of window/screen)
  396. *--               cText  = Message to center on screen
  397. *--------------------------------------------------------------------------
  398.     
  399.     parameters nLine,nWidth,cColor,cText
  400.     
  401.     nCol = (nWidth - len(cText)) /2
  402.     @nLine,nCol say cText color &cColor.
  403.     
  404. RETURN
  405. *-- EoP: Center
  406.  
  407. FUNCTION Center2
  408. *--------------------------------------------------------------------------
  409. *-- Programmer..: Jeff Riedl (Student)
  410. *-- Date........: 05/24/1991
  411. *-- Notes.......: centers text, only two parameters and is a function.
  412. *-- Written for.: dBASE IV, 1.1
  413. *-- Rev. History: None
  414. *-- Calls.......: None
  415. *-- Called by...: Any
  416. *-- Usage.......: center2(<nWidth>,"<cText>")
  417. *-- Example.....: @row,center2(80,"Center this text") say "Center this text"
  418. *--                  or
  419. *--               @row,center2(80,"&MemVar") say MemVar
  420. *-- Returns.....: centered text
  421. *-- Parameters..: nWidth = Width of screen
  422. *--               cText  = Text to be centered
  423. *--------------------------------------------------------------------------
  424.  
  425.     parameters nWidth,cText
  426.     
  427. RETURN (nWidth - len(cText)) / 2
  428. *-- EoF: Center2
  429.  
  430. FUNCTION Surround
  431. *--------------------------------------------------------------------------
  432. *-- Programmer..: Miriam Liskin
  433. *-- Date........: 05/24/1991
  434. *-- Notes.......: Displays a message surrounded by a box anywhere on 
  435. *--               the screen
  436. *-- Written for.: dBASE IV, 1.1
  437. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (Kenmayer) to a function
  438. *--                from original procedure
  439. *-- Calls.......: None
  440. *-- Called by...: Any
  441. *-- Usage.......: surround(<nLine>,<nColumn>,"<cColor>","<cText>")
  442. *-- Example.....: lc_Dummy = surround(5,12,"RG+/GB",;
  443. *--                          "Processing ... Do not Touch!")
  444. *-- Returns.....: Nul/""
  445. *-- Parameters..: nLine   = Line to display "surrounded" message at
  446. *--               nColumn = Column for same (X,Y coordinates for @SAY)
  447. *--               cColor  = Color variable/colors
  448. *--               cText   = Text to be displayed inside box
  449. *--------------------------------------------------------------------------
  450.     
  451.     parameters nLine,nColumn,cColor,cText
  452.     
  453.     cText = " " + trim(cText) + " "             && add spaces around text
  454.     @nLine-1,nColumn-1 to nLine+1,nColumn+len(cText) double;
  455.         color &cColor.                           && draw box
  456.     @nLine,nColumn say cText color &cColor.  && disp. text
  457.     
  458. RETURN "" 
  459. *-- EoF: Surround
  460.  
  461. FUNCTION Message1
  462. *--------------------------------------------------------------------------
  463. *-- Programmer..: Miriam Liskin
  464. *-- Date........: 05/24/1991
  465. *-- Notes.......: Displays a message, centered at whatever line you give,
  466. *--               pauses until user presses a key.
  467. *-- Written for.: dBASE IV, 1.1
  468. *-- Rev. History: 04/19/1991 Modified by Ken Mayer (Kenmayer) from Miriam's 
  469. *--                procedure to function
  470. *-- Calls.......: CENTER               (procedure in PROC.PRG)
  471. *-- Called by...: Any
  472. *-- Usage.......: message1(<nLine>,<nWidth>,"<cColor>","<cText>")
  473. *-- Example.....: lc_Dummy = Message1(5,12,"RG+/GB","All Done.")
  474. *-- Returns.....: numeric value of key pressed by user (cUser)
  475. *-- Parameters..: nLine  = Line to display message
  476. *--               nWidth = Width of screen
  477. *--               cColor = Colors for display
  478. *--               cText  = Text to be displayed.
  479. *--------------------------------------------------------------------------
  480.  
  481.     parameters nLine,nWidth,cColor,cText
  482.     
  483.     @nLine,0
  484.     cCursor = set("CURSOR")  && store current state of CURSOR
  485.     set cursor off           && turn it off
  486.     do center with nLine,nWidth,cColor,cText
  487.     wait "" to cUser
  488.     set cursor &cCursor      && set cursor to original state
  489.     @nLine,0                 && erase line ...
  490.  
  491. RETURN cUser
  492. *-- EoF: Message1
  493.  
  494. FUNCTION Message2
  495. *--------------------------------------------------------------------------
  496. *-- Programmer..: Miriam Liskin
  497. *-- Date........: 05/23/1991
  498. *-- Notes.......: Displays a message in a window, pauses for user to 
  499. *--               press key
  500. *-- Written for.: dBASE IV, 1.1
  501. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (Kenmayer) to a function
  502. *--               04/29/1991 - Modified by Ken Mayer (Kenmayer) to add shadow
  503. *-- Calls.......: SHADOW               (procedure in PROC.PRG)
  504. *--               CENTER               (procedure in PROC.PRG)
  505. *-- Called by...: Any
  506. *-- Usage.......: message2("<cText>","<cColor>")
  507. *-- Example.....: lc_Dummy = message2("Finished Processing!",;
  508. *--                   "RG+/GB,,RG+/GB")
  509. *-- Returns.....: numeric value of key pressed by user (cUser)
  510. *-- Parameters..: cText  = Text to be displayed in window
  511. *--               cColor = Colors for window
  512. *--------------------------------------------------------------------------
  513.  
  514.     parameters cText,cColor
  515.     
  516.     cCursor = set("CURSOR")
  517.     set cursor off
  518.     save screen to sMessage
  519.     define window wMessage from 10,10 to 14,70 double color &cColor.
  520.     do shadow with 10,10,14,70
  521.     activate window wMessage
  522.     
  523.     do center with 1,60,"",cText
  524.     wait "" to cUser
  525.     
  526.     set cursor &cCursor
  527.     deactivate window wMessage
  528.     release window wMessage
  529.     restore screen from sMessage
  530.     release screen sMessage
  531.  
  532. RETURN cUser
  533. *-- EoF: Message2
  534.  
  535. FUNCTION Message3
  536. *--------------------------------------------------------------------------
  537. *-- Programmer..: Miriam Liskin
  538. *-- Date........: 05/23/1991
  539. *-- Notes.......: Displays a message in a window, pauses for user, 
  540. *--               will wrap a long message inside the window.
  541. *-- Written for.: dBASE IV, 1.1
  542. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (Kenmayer) to a function
  543. *--               04/29/1991 - Modified to Ken Mayer (Kenmayer) add shadow
  544. *-- Calls.......: SHADOW               (procedure in PROC.PRG)
  545. *-- Called by...: Any
  546. *-- Usage.......: Message3("<cText>","<cColor>")
  547. *-- Example.....: lc_Dummy = Message3("This is a long message that will be"+;
  548. *--                 "wrapped around inside the window.","rg+/gb,,rg+/gb")
  549. *-- Returns.....: numeric value of key used to exit window (cUser)
  550. *-- Parameters..: cText  = Text to be displayed
  551. *--               cColor = Colors for window
  552. *--------------------------------------------------------------------------
  553.  
  554.     parameters cText,cColor
  555.     
  556.     nLines = int(len(cText) / 38) + 5    && set # of lines for window
  557.     
  558.     cCursor = set("CURSOR")
  559.     set cursor off
  560.     save screen to sMessage
  561.     define window wMessage from 8,20 to 8+nLines,60 double color &cColor.
  562.     do shadow with 8,20,8+nLines,60
  563.     activate window wMessage
  564.     
  565.     nLmargin   = _lmargin
  566.     nRmargin   = _rmargin
  567.     cAlignment = _alignment
  568.     lWrap      = _wrap
  569.     
  570.     _lmargin   = 1 
  571.     _rmargin   = 38
  572.     _alignment = "CENTER"
  573.     _wrap      = .t.
  574.     
  575.     ?cText
  576.     ?
  577.     wait "    Press any key to continue . . ." to cUser
  578.     
  579.     _lmargin   = nLmargin
  580.     _rmargin   = nRmargin
  581.     _alignment = cAlignment
  582.     _wrap      = lWrap
  583.     
  584.     set cursor &cCursor
  585.     deactivate window wMessage
  586.     release window wMessage
  587.     restore screen from sMessage
  588.     release screen sMessage
  589.  
  590. RETURN cUser
  591. *-- EoF: Message3
  592.  
  593. FUNCTION Message4
  594. *--------------------------------------------------------------------------
  595. *-- Programmer..: Miriam Liskin
  596. *-- Date........: 05/23/1991
  597. *-- Notes.......: Displays a 2-line message in a predefined window 
  598. *--                 and pauses
  599. *-- Written for.: dBASE IV, 1.1
  600. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (Kenmayer) to a function
  601. *--               04/29/1991 - Modified to Ken Mayer (Kenmayer) add shadow
  602. *-- Calls.......: SHADOW               (procedure in PROC.PRG)
  603. *--               CENTER               (procedure in PROC.PRG)
  604. *-- Called by...: Any
  605. *-- Usage.......: message4("<cText1>","<cText2>","<cColor>")
  606. *-- Example.....: lc_Dummy = message4("Finished processing.","There are ";
  607. *--                 +ltrim(str(reccount()))+" Records in this file.",;
  608. *--                 "rg+/rg,rg+/rg,rg+/rg")
  609. *-- Returns.....: numeric value of key pressed by user to exit window (cUser)
  610. *-- Parameters..: cText1 = First line of message
  611. *--               cText2 = Second line of message
  612. *--               cColor = Colors for window
  613. *--------------------------------------------------------------------------
  614.  
  615.     parameters cText1,cText2,cColor
  616.     
  617.     cCursor = set("CURSOR")
  618.     set cursor off
  619.     save screen to sMessage
  620.     define window wMonitor from 10,10 to 17,70 double color &cColor.
  621.     do shadow with 10,10,17,70
  622.     activate window wMonitor
  623.     
  624.     nLmargin = _lmargin
  625.     nRmargin = _rmargin
  626.     lWrap =    _wrap
  627.  
  628.     _lmargin = 1 
  629.     _rmargin = 58
  630.     _wrap    = .t.
  631.     
  632.     do center with 1,58,"",cText1
  633.     do center with 2,58,"",cText2
  634.     do center with 4,58,"","Press any key to continue . . ."
  635.     wait "" to cUser
  636.  
  637.     _lmargin = nLmargin
  638.     _rmargin = nRmargin
  639.     _wrap    = lWrap
  640.     
  641.     set cursor &cCursor
  642.     deactivate window wMonitor
  643.     release window wMonitor
  644.     restore screen from sMessage
  645.     release screen sMessage
  646.     
  647. RETURN cUser
  648. *-- EoF: Message4
  649.  
  650. PROCEDURE Monitor
  651. *--------------------------------------------------------------------------
  652. *-- Programmer..: Miriam Liskin
  653. *-- Date........: 05/23/1991
  654. *-- Notes.......: Displays a status message to monitor a long-running 
  655. *--                 operation that operates on multiple records . . . 
  656. *--                 Should be used with MONITOROFF (below) to cleanup.
  657. *-- Written for.: dBASE IV, 1.1
  658. *-- Rev. History: 04/29/1991 - Modified by Ken Mayer (Kenmayer) to add shadow
  659. *-- Calls.......: SHADOW               (procedure in PROC.PRG)
  660. *--               CENTER               (procedure in PROC.PRG)
  661. *-- Called by...: Any
  662. *-- Usage.......: do monitor with "<cText>","<cColor>"
  663. *-- Example.....: do monitor with "Processing REPORT.DBF","rg+/gb,rg+/gb,rg+/gb"
  664. *--               ln_recnum = 0
  665. *--               do while  && (or SCAN)
  666. *--                  stuff -- process records
  667. *--                  ln_recnum = ln_recnum + 1
  668. *--                  @4,30 display ltrim(str(ln_recnum)) && current record
  669. *--                                                      && in window MONITOR
  670. *--               enddo  && (or endscan)
  671. *--               do monitoroff  && procedure to clean-up after this one
  672. *-- Returns.....: None
  673. *-- Parameters..: cText  = Text to display
  674. *--               cColor = Colors for window
  675. *--------------------------------------------------------------------------
  676.  
  677.     parameters cText,cColor
  678.     
  679.     save screen to sMonitor
  680.     define window wMonitor From 10,10 to 18,70 double color &cColor.
  681.     do shadow with 10,10,18,70
  682.     activate window wMonitor
  683.     
  684.     do center with 1,60,"",cText
  685.     do center with 2,60,"","Please do not interrupt"
  686.     @4,10 say "Working on record          of " + ltrim(str(reccount(),5))
  687.     
  688. RETURN
  689. *-- EoP: Monitor
  690.  
  691. PROCEDURE MonitorOff
  692. *--------------------------------------------------------------------------
  693. *-- Programmer..: Ken Mayer (Kenmayer)
  694. *-- Date........: 05/23/1991
  695. *-- Notes.......: Used to deal with ending routines for MONITOR
  696. *--                 procedure above.
  697. *-- Written for.: dBASE IV, 1.1
  698. *-- Rev. History: None
  699. *-- Calls.......: None
  700. *-- Called by...: Routine using MONITOR  (procedure in PROC.PRG)
  701. *-- Usage.......: do monitoroff
  702. *-- Example.....: do monitoroff
  703. *-- Returns.....: None
  704. *-- Parameters..: None
  705. *--------------------------------------------------------------------------
  706.  
  707.     deactivate window wMonitor
  708.     release window wMonitor
  709.     restore screen from sMonitor
  710.     release screen sMonitor
  711.     
  712. RETURN
  713. *-- EoP: MonitorOff
  714.  
  715. FUNCTION ScrnHead
  716. *--------------------------------------------------------------------------
  717. *-- Programmer..: Miriam Liskin
  718. *-- Date........: 05/23/1991
  719. *-- Notes.......: Displays a heading on the screen in a box 2 
  720. *--               spaces wider than the text, with a custom border (double 
  721. *--               line top, single the rest)
  722. *-- Written for.: dBASE IV, 1.1
  723. *-- Rev. History: 4/29/1991 - Modified by Ken Mayer (Kenmayer) to add shadow
  724. *-- Calls.......: SHADOW               (procedure in PROC.PRG)
  725. *-- Called by...: Any
  726. *-- Usage.......: scrnhead("<cColor>","<cText>")
  727. *-- Examples....: lc_Dummy = ScrnHead("rg+/gb","Print Financial Report")
  728. *-- Returns.....: nul/""
  729. *-- Parameters..: cColor = Colors to display box/text in
  730. *--               cText  = text to be displayed.
  731. *--------------------------------------------------------------------------
  732.  
  733.     parameters cColor,cText
  734.     
  735.     cText = " "+trim(cText)+" "              && ad spaces to left and right
  736.     cTextstart = (80-len(trim(cText)))/2
  737.     do shadow with 1,cTextstart-1,3,81-cTextstart
  738.     @1,cTextstart-1 to 3,81-cTextstart 205,196,179,179,213,184,192,217;
  739.         color &cColor.                          && display box
  740.     @2, cTextstart say cText color &cColor. && display text
  741.  
  742. RETURN ""
  743. *-- EoF: ScrnHead
  744.  
  745. FUNCTION YesNo
  746. *--------------------------------------------------------------------------
  747. *-- Programmer..: Miriam Liskin
  748. *-- Date........: 05/23/1991
  749. *-- Notes.......: Asks a yes/no question in a dialog window/box
  750. *-- Written for.: dBASE IV, 1.1
  751. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
  752. *--               04/29/1991 - Modified to Ken Mayer add shadow
  753. *--               05/13/1991 - Modified to Ken Mayer remove need for extra 
  754. *--                            procedures (YES/NO) that were used for returning
  755. *--                            values from Menu
  756. *--                            (suggested by Clinton L. Warren (VBCES on ATBBS))
  757. *-- Calls.......: SHADOW               (procedure in PROC.PRG)
  758. *--               CENTER               (procedure in PROC.PRG)
  759. *-- Called by...: Any
  760. *-- Usage.......: yesno(<lAnswer>,"<cMess1>","<cMess2>","<cMess3>","<cColor>")
  761. *-- Example.....: if YesNo(.t.,"Do You Really Wish To Delete?",;
  762. *--                            "This will destroy the data";
  763. *--                             "in this record.";
  764. *--                             "rg+/gb,n/w,rg+/gb")
  765. *--                  delete
  766. *--               else
  767. *--                  skip
  768. *--               endif
  769. *--
  770. *--                 The middle set of colors should be different, as they
  771. *--                 will be the colors of the YES/NO selections ...
  772. *--                 Options may be blank by using nul values ("")
  773. *-- Returns.....: .t./.f. depending on user's choice from menu
  774. *-- Parameters..: lAnswer = default value (Yes or No) for menu
  775. *--               cMess1  =  First line of Message
  776. *--               cMess2  =  Second line of message
  777. *--               cMess3  =  Third line of message
  778. *--               cColor  =  Colors for window/menu/box
  779. *--------------------------------------------------------------------------
  780.  
  781.     parameter lAnswer,cMess1,cMess2,cMess3,cColor
  782.     
  783.     save screen to sYesno
  784.     define window wYesno from 8,20 to 15,60 double color &cColor.
  785.     
  786.     define menu mYesno
  787.     define pad pYes of mYesno Prompt "[Yes]" at 5,10
  788.     define pad pNo  of mYesno Prompt "[No]"  at 5,25
  789.     on selection pad pYes of mYesno deactivate menu
  790.     on selection pad pNo  of mYesno deactivate menu
  791.     
  792.     do shadow with 8,20,15,60
  793.     activate window wYesno
  794.     nLmargin = _lmargin    && store system values
  795.     nRmargin = _rmargin
  796.     lWrap    = _wrap
  797.     _lmargin   = 2            && set local values
  798.     _rmargin   = 38
  799.     _wrap      = .t.
  800.     
  801.     do center with 0,38,"",cMess1        && center the text
  802.     do center with 2,38,"",cMess2
  803.     do center with 3,38,"",cMess3
  804.     if lAnswer
  805.         activate menu mYesno pad pYes
  806.     else
  807.         activate menu mYesno pad pNo
  808.     endif
  809.     
  810.     _lmargin = nLmargin    && reset system values
  811.     _rmargin = nRmargin
  812.     _wrap    = lWrap
  813.     
  814.     deactivate window wYesno
  815.     release window wYesno
  816.     restore screen from sYesno
  817.     release screen sYesno
  818.     release menu mYesno
  819.  
  820. RETURN iif(pad()="PYES",.t.,.f.)
  821. *-- EoF: YesNo
  822.  
  823. FUNCTION ErrorMsg
  824. *--------------------------------------------------------------------------
  825. *-- Programmer..: Ken Mayer (Kenmayer)
  826. *-- Date........: 05/23/1991
  827. *-- Notes.......: Display an error message in a Window: 
  828. *--                           ** ERROR [#] **
  829. *--
  830. *--                              Message 1
  831. *--                              Message 2
  832. *--                       Press any key to continue ...
  833. *--
  834. *--                 colors should be VIVID, since it's an error message.
  835. *-- Written for.: dBASE IV, 1.1
  836. *-- Rev. History: None
  837. *-- Calls.......: SHADOW               (procedure in PROC.PRG)
  838. *--               CENTER               (procedure in PROC.PRG)
  839. *-- Called by...: Any
  840. *-- Usage.......: ErrorMsg("<cErr>","<cMess1>","<cMess2>","<cColor>")
  841. *-- Example.....: lc_Dummy = errormsg("3","This record","already exists!",;
  842. *--                   "rg+/r,rg+/r,rg+/r")
  843. *--               where "errornum" is an error number or nul,
  844. *--               message2 and 3 should be 36 characters or less ...
  845. *--               Colors should include foreground/background,;
  846. *--                 foreground/background,foreground/background
  847. *-- Returns.....: numeric value of keystroke user presses (cUser)
  848. *-- Parameters..: cErr   = Error # (can be blank, but use "" for blank)
  849. *--               cMess1 = Error message line 1
  850. *--               cMess2 = Error message line 2
  851. *--               cColor = Colors for text/window/border
  852. *--------------------------------------------------------------------------
  853.     
  854.     parameters cErr,cMess1,cMess2,cColor
  855.     
  856.     save screen to sErr
  857.     define window wErr from 8,20 to 15,60 double color &cColor.
  858.     do shadow with 8,20,15,60
  859.     activate window wErr
  860.     
  861.     cCursor = set("CURSOR")
  862.     set cursor off
  863.     if len(trim(cErr)) > 0  && if there's an error number ...
  864.         do center with 0,38,"","** ERROR "+alltrim(cErr)+" **"
  865.     else                      && otherwise, don't display errornumber
  866.         do center with 0,38,"","** ERROR **"
  867.     endif
  868.     do center with 2,38,"",cMess1
  869.     do center with 3,38,"",cMess2
  870.     do center with 5,38,"","Press any key to continue ..."
  871.     cUser=inkey(0)
  872.     set cursor &cCursor
  873.     
  874.     deactivate window wErr
  875.     release window wErr
  876.     restore screen from sErr
  877.     release screen sErr
  878.     
  879. RETURN cUser
  880. *-- EoF: ErrorMsg
  881.  
  882. FUNCTION DateText
  883. *--------------------------------------------------------------------------
  884. *-- Programmer..: Miriam Liskin
  885. *-- Date........: 05/23/1991
  886. *-- Notes.......: Display date in format Month, day year (e.g., July 1,1991)
  887. *-- Written for.: dBASE IV, 1.1
  888. *-- Rev. History: None
  889. *-- Calls.......: None
  890. *-- Called by...: Any
  891. *-- Usage.......: DateText(<dDate>) 
  892. *-- Example.....: ? datetext(date())
  893. *-- Returns.....: July 1, 1991
  894. *-- Parameters..: dDate = date to be converted
  895. *--------------------------------------------------------------------------
  896.  
  897.     parameters dDate
  898.     
  899. RETURN CMONTH(dDate)+" "+ltrim(str(day(dDate),2))+", "+;
  900.        str(year(dDate),4)
  901. *-- EoF: DateText
  902.  
  903. FUNCTION DateText2
  904. *--------------------------------------------------------------------------
  905. *-- Programmer..: Miriam Liskin
  906. *-- Date........: 05/23/1991
  907. *-- Notes.......: Display date in format day-of-week, Month day, year
  908. *-- Written for.: dBASE IV, 1.1
  909. *-- Rev. History: None
  910. *-- Calls.......: None
  911. *-- Called by...: Any
  912. *-- Usage.......: DateText2(<dDate>)
  913. *-- Example.....: ? DateText2(date())
  914. *-- Returns.....: Thursday, July 1, 1991
  915. *-- Parameters..: dDate = date to be converted
  916. *--------------------------------------------------------------------------
  917.  
  918.     parameters dDate
  919.     
  920. RETURN CDOW(dDate)+", "+cmonth(dDate)+" "+;
  921.        ltrim(str(day(dDate),2))+", "+str(year(dDate),4)
  922. *-- EoF: DateText2
  923.  
  924. FUNCTION IsUnique
  925. *--------------------------------------------------------------------------
  926. *-- Programmer..: Clinton L. Warren (VBCES)
  927. *-- Date........: 07/23/1991
  928. *-- Notes.......: Checks to see if an index key already exists in the current
  929. *--               selected database. This function was inspired by Tom
  930. *--               Woodward's Chk4Dup UDF.
  931. *-- Written for.: dBASE IV, 1.1
  932. *-- Rev. History: May 15, 1991 Version 1.1  Added check for zero record database
  933. *--               May  7, 1991 Version 1.0  Initial 'release'.
  934. *-- Calls.......: None
  935. *-- Called by...: Any
  936. *-- Usage.......: IsUnique(<xValue>,<cOrder>)
  937. *-- Example.....: @x,y SAY "SSN: " GET SSN PICTURE "999-99-9999";
  938. *--                  valid required IsUnique(SSN, SSN);
  939. *--                  message "Enter a new SSN";
  940. *--                  error chr(7)+"SSN must be unique!"
  941. *-- Returns.....: .T./.F.
  942. *-- Parameters..: xValue = Value (any non-memo type) to check for uniqueness
  943. *--               cOrder = MDX Tag used to order the database. Must be set for
  944. *--                        field being checked.
  945. *--------------------------------------------------------------------------
  946.     
  947.     parameters xValue, cOrder
  948.     
  949.     nRecNo = recno()           && store current record number
  950.     nRecCnt = reccount()       && count records in database
  951.     
  952.     if nRecCnt = 0             && empty database, cValue MUST be unique
  953.        return .t.
  954.     endif
  955.     
  956.     cSetNear = set('NEAR')     && store status of NEAR flag
  957.     set near off               && set it off
  958.     c_SetDel = set('DELETE')   && store status of DELETE
  959.     set delete on              && Delete must be ON for this to work
  960.     lIsDeleted = deleted()     && is current record deleted?
  961.     delete                     && set delete flag for current record
  962.     cSetOrder = order()        && store current MDX tag
  963.     set order to (cOrder)      && set tag to that sent to function
  964.     
  965.     if seek(xValue)            && does it exist already?
  966.        lIsUnique = .f.         &&   if so, it's not unique
  967.     else                       && otherwise,
  968.        lIsUnique = .t.         &&   it is.
  969.     endif
  970.    
  971.    set order to (cSetOrder)   && restore changed settings to original settings
  972.    set delete &cSetDel
  973.    set near &cSetNear
  974.    
  975.    if nRecNo > nRecCnt        && if called during an append
  976.       go bottom               && goto the bottom of the database,
  977.       skip 1                  &&   plus one record (the new one)
  978.    else
  979.       go nRecNo               && otherwise, goto the current record number
  980.    endif
  981.  
  982.    if .not. lIsDeleted        && was record 'deleted' before?
  983.       recall                  && if not, undelete it ... (turn flag off)
  984.    endif 
  985.  
  986. RETURN (lIsUnique)
  987. *-- EoF: IsUnique
  988.  
  989. FUNCTION Proper
  990. *------------------------------------------------------------------------------
  991. *-- Programmer..: Clinton L. Warren (VBCES/CLW)
  992. *-- Date........: 07/10/1991
  993. *-- Notes.......: Returns cBaseStr converted to proper case.  Converts
  994. *--             : "Mc", "Mac", and "'s" as special cases.  Inspired by
  995. *--             : A-T's CCB Proper function.  cBaseStr isn't modified.
  996. *-- Written for.: dBASE IV, 1.1
  997. *-- Rev. History: 07/10/1991 1.0 - Original version (VBCES/CLW)
  998. *-- Calls.......: None
  999. *-- Called by...: Any
  1000. *-- Usage.......: Proper(<cArg>)
  1001. *-- Example.....: Proper("mcdonald's") returns "McDonald's"
  1002. *-- Returns.....: Propertized string (e.g. "Test String")
  1003. *-- Parameters..: cArg = String to be propertized
  1004. *------------------------------------------------------------------------------
  1005.  
  1006.     PARAMETERS cBaseStr
  1007.  
  1008.     private nPos, cDeli, cWrkStr
  1009.  
  1010.     cWrkStr = lower(cBaseStr) + ' '             && space necessary for 's process
  1011.  
  1012.     nPos = at('mc', cWrkStr)                    && "Mc" handling
  1013.     do while nPos # 0
  1014.        cWrkStr = stuff(cWrkStr, nPos, 3, upper(substr(cWrkStr, nPos, 1)) ;
  1015.                         + lower(substr(cWrkStr, nPos + 1, 1)) ;
  1016.                                     + upper(substr(cWrkStr, nPos + 2, 1)))
  1017.         nPos = at('mc', cWrkStr)
  1018.       enddo
  1019.  
  1020.     nPos = at('mac', cWrkStr)                    && "Mac" handling
  1021.     do while nPos # 0
  1022.        cWrkStr = stuff(cWrkStr, nPos, 4, upper(substr(cWrkStr, nPos, 1)) ;
  1023.                                 + lower(substr(cWrkStr, nPos + 1, 2)) ;
  1024.                                 + upper(substr(cWrkStr, nPos + 3, 1)))
  1025.         nPos = at('mac', cWrkStr)
  1026.     enddo
  1027.  
  1028.     cWrkStr = stuff(cWrkStr, 1, 1, upper(substr(cWrkStr, 1, 1)))
  1029.     nPos = 2
  1030.     cDeli = [ -.'"\/`]                           && standard delimiters
  1031.  
  1032.     do while nPos <= len(cWrkStr)                && 'routine' processing
  1033.         if substr(cWrkStr,nPos-1,1) $ cDeli
  1034.           cWrkStr = stuff(cWrkStr, nPos, 1, upper(substr(cWrkStr,nPos,1)))
  1035.         endif
  1036.         nPos = nPos + 1
  1037.     enddo
  1038.  
  1039.     nPos = at("'S ", cWrkStr)                    && 's processing
  1040.     do while nPos # 0
  1041.         cWrkStr = stuff(cWrkStr, nPos, 2, lower(substr(cWrkStr, nPos, 2)))
  1042.         nPos = at('mac', cWrkStr)
  1043.     enddo
  1044.  
  1045. RETURN (cWrkStr)
  1046. *-- EoF: Proper()
  1047.  
  1048. FUNCTION AllTrim
  1049. *--------------------------------------------------------------------------
  1050. *-- Programmer..: Phil Steele (from PCSDEMO.PRG -- Public Domain)
  1051. *-- Date........: 5/23/1991
  1052. *-- Notes.......: Complete trims edges of field (left and right)
  1053. *-- Written for.: dBASE IV, 1.1
  1054. *-- Rev. History: None
  1055. *-- Calls.......: None
  1056. *-- Called by...: Any
  1057. *-- Usage.......: alltrim(<cString>)
  1058. *-- Example.....: ? alltrim("  Test String  ") 
  1059. *-- Returns.....: Trimmed string, i.e.:"Test String"
  1060. *-- Parameters..: cString = string to be trimmed
  1061. *--------------------------------------------------------------------------
  1062.     
  1063.     parameters cString
  1064.     
  1065. RETURN ltrim(rtrim(cString))
  1066. *-- EoF: AllTrim
  1067.  
  1068. PROCEDURE Shadow
  1069. *--------------------------------------------------------------------------
  1070. *-- Programmer..: Ashton-Tate
  1071. *-- Date........: 5/23/1991
  1072. *-- Notes.......: Creates a shadow for a window (taken from the dBASE IV
  1073. *--               picklist functions)
  1074. *-- Written for.: dBASE IV, 1.1
  1075. *-- Rev. History: None
  1076. *-- Calls.......: None
  1077. *-- Called by...: Any
  1078. *-- Usage.......: do shadow with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
  1079. *-- Example.....: save screen to sc_Main
  1080. *--               define window w_Error from 5,15 to 15,65 double color;
  1081. *--                    rg+/r,rg+/r,rg+/r
  1082. *--               do shadow with 5,15,15,65
  1083. *--               activate window W_Error
  1084. *--                && perform actions in window
  1085. *--               deactivate window W_Error
  1086. *--               release window W_Error
  1087. *--               restore screen from sc_Main
  1088. *--               release screen sc_Main
  1089. *-- Returns.....: None
  1090. *-- Parameters..: nULRow = Upper Left Row position
  1091. *--               nULCol = Upper Left Column position (x,y)
  1092. *--               nBRRow = Bottom Right Row position
  1093. *--               nBRCol = Bottom Right Column position (x2,y2)
  1094. *--------------------------------------------------------------------------
  1095.  
  1096.     parameters nULRow,nULCol,nBRRow,nBRCOL
  1097.  
  1098.     nTempRow = nBRRow+1
  1099.     nTempCol = nBRCol+2
  1100.     nIncRow = 1
  1101.     nIncCol = (nBRCol-nULCol) / (nBRRow-nULRow)
  1102.     do while nTempRow <> nULRow .or. nTempCol <> nULCol+2
  1103.         @ nTempRow,nTempCol fill to nBRRow+1,nBRCol+2 color n+/n
  1104.         nTempRow = iif(nTempRow<>nULRow,nTempRow - nIncRow,nTempRow)
  1105.         nTempCol = iif(nTempCol<>nULCol+2,nTempCol - nIncCol,nTempCol)
  1106.         nTempCol = iif(nTempCol<nULCol+2,nULCol+2,nTempCol)
  1107.     enddo
  1108.     
  1109. RETURN
  1110. *-- EoP: Shadow
  1111.  
  1112. PROCEDURE FullWin
  1113. *--------------------------------------------------------------------------
  1114. *-- Programmer..: Ken Mayer (Kenmayer)
  1115. *-- Date........: 05/23/91
  1116. *-- Notes.......: Overlays menus or another screen with a full window,
  1117. *--               so that processing is done in the window, and one can return
  1118. *--               directly to the menus, without redrawing screen and such.
  1119. *-- Written for.: dBASE IV, 1.1
  1120. *-- Rev. History: None
  1121. *-- Calls.......: None
  1122. *-- Called by...: Any
  1123. *-- Usage.......: do fullwin with <cColor>,<cWinName>,<cScreen>
  1124. *-- Example.....: do fullwin with "w+/b","w_Edit","sc_Main"
  1125. *--                * perform whatever actions are needed in the window
  1126. *--               deactivate window w_Edit
  1127. *--               release window w_Edit
  1128. *--               restore screen from sc_Main
  1129. *--               release screen sc_Main
  1130. *-- Returns.....: None
  1131. *-- Parameters..: cColor   = Colors for window
  1132. *--               cWinName = Name of window
  1133. *--               cScreen  = Name of screen
  1134. *--------------------------------------------------------------------------
  1135.     
  1136.     parameters cColor,cWinName,sScreen
  1137.     
  1138.     define window &cWinName from 0,0 to 23,79 none color &cColor.
  1139.     save screen to &sScreen.
  1140.     activate window &cWinName.
  1141.     
  1142. RETURN  
  1143. *-- EoP: FullWin
  1144.  
  1145. FUNCTION DosRun
  1146. *--------------------------------------------------------------------------
  1147. *-- Programmer..: Michael P. Dean (Ashton-Tate)
  1148. *-- Date........: 05/23/1991
  1149. *-- Notes.......: A routine to run a DOS program, checks to see if a
  1150. *--               window is active -- if so, it avoids the inevitable
  1151. *--               "Press any key to continue" and the subsequent messing
  1152. *--               up of the screen display.
  1153. *-- Written for.: dBASE IV, 1.1
  1154. *-- Rev. History: Pulled from A-T BBS 
  1155. *--               05/13/1991 - modified by Ken Mayer (Kenmayer) to use the DBASE
  1156. *--                 RUN() function, rather than the ! or RUN commands,
  1157. *--                 which allows the return of DOS exit codes ... (suggested
  1158. *--                 by Clinton L. Warren (VBCES).)
  1159. *-- Calls.......: None
  1160. *-- Called by...: Any
  1161. *-- Usage.......: DosRun(<cCmd>)
  1162. *-- Example.....: lc_dummy = dosrun("DIR /W /P")
  1163. *--                 * or
  1164. *--               lc_dummy = dosrun(memvar)  && where memvar contains dos
  1165. *--                                          && command and parameters ...
  1166. *-- Returns.....: NUMERIC value of the DOS exit code (nRun)
  1167. *-- Parameters..: cCmd = Command (and parameters) to be executed
  1168. *--------------------------------------------------------------------------
  1169.  
  1170.     parameter cCmd
  1171.     
  1172.     wWindow = window()              && grab window name of current window
  1173.     if len(trim(wWindow)) > 0       && if there's a window,
  1174.         deactivate window &wWindow   && deactivate it
  1175.     endif
  1176.     set console off                  && don't display to screen
  1177.     nRun = run("&cCmd")              && place DOS exit code in NRUN
  1178.     set console on                   && ok, display to screen
  1179.     if len(trim(wWindow)) > 0        && if there's a window,
  1180.         activate window &wWindow      && reactivate it
  1181.     endif
  1182.     
  1183. RETURN nRun
  1184. *-- EoF: DosRun
  1185.  
  1186. *-------------------------------------------------------------------------------
  1187. *-- The next four functions are used for FRPGs (Fantasy Role-Playing Games)
  1188. *-------------------------------------------------------------------------------
  1189.  
  1190. FUNCTION Dice
  1191. *--------------------------------------------------------------------------
  1192. *-- Programmer..: Ken Mayer (Kenmayer)
  1193. *-- Date........: 05/23/1991
  1194. *-- Notes.......: A small function used to determine a random number from
  1195. *--               1 to x. Used for gaming purposes.
  1196. *-- Written for.: dBASE IV, 1.1
  1197. *-- Rev. History: None
  1198. *-- Calls.......: None
  1199. *-- Called by...: Any/MultDice()       (Function in PROC.PRG)
  1200. *-- Usage.......: Dice(<nSides>)
  1201. *-- Example.....: ln_val = Dice(4)
  1202. *-- Returns.....: Random # between 1 and <nSides>
  1203. *-- Parameters..: nSides = # of sides of die to be cast ... (RPG dice
  1204. *--                        include 4, 6 (standard), 8, 10, 12, 20, 100 ...
  1205. *--------------------------------------------------------------------------
  1206.  
  1207.     parameters nSides
  1208.     nSeed = (val(substr(time(),1,2))+val(substr(time(),4,2))+;
  1209.              val(substr(time(),7,2))) * val(substr(time(),7,2))
  1210.  
  1211. RETURN int(rand(nSeed) * nSides) + 1
  1212. *-- EoF: Dice
  1213.  
  1214. FUNCTION MultDice
  1215. *--------------------------------------------------------------------------
  1216. *-- Programmer..: Ken Mayer (Kenmayer)
  1217. *-- Date........: 06/12/1991
  1218. *-- Notes.......: Function like above, used to determine a random #,
  1219. *--               but for multiple dice, of x# of sides.
  1220. *-- Written for.: dBASE IV, 1.1
  1221. *-- Rev. History: Originally this called DICE for each iteration, but it
  1222. *--                turned out that calling that routine more than once
  1223. *--                was resetting the randomizer seed to a similar or same
  1224. *--                value, and we got (quite often) the exact same number
  1225. *--                for each iteration. SO, now this routine calls DICE once,
  1226. *--                which sets the seed, and if we want more than one die,
  1227. *--                we loop and call RAND without a new seed. It works.
  1228. *-- Calls.......: DICE()               (Function in PROC.PRG)
  1229. *-- Called by...: Any
  1230. *-- Usage.......: MultDice(<nNum>,<nSides>)
  1231. *-- Example.....: ln_val = MultDice(3,6)
  1232. *-- Returns.....: Random value of 1 to x (x being number of sides), 
  1233. *--                for each iteration (nNum), totalled. For example,
  1234. *--                value returned would be the total of 3 six-sided die
  1235. *--                rolled, the number would be anywhere from 3 to 18.
  1236. *-- Parameters..: nNum   = Number of dice to be "rolled"
  1237. *--               nSides = # of sides to the dice (see Dice() above)
  1238. *--------------------------------------------------------------------------
  1239.  
  1240.     parameters nNum,nSides
  1241.     
  1242.     nTotal = dice(nSides)                  && call DICE and set RAND seed
  1243.     nCount = 1                             && set counter
  1244.     do while nCount < nNum                 && loop for number of dice 
  1245.         nNewval = int(rand() * nSides) + 1  && get new random value
  1246.         nTotal = nTotal + nNewval           && add to total
  1247.         nCount = nCount + 1                 && increment counter
  1248.     enddo
  1249.     
  1250. RETURN nTotal
  1251. *-- EoF: MultDice
  1252.  
  1253. FUNCTION ValiDice
  1254. *--------------------------------------------------------------------------
  1255. *-- Programmer..: Ken Mayer (KenMayer)
  1256. *-- Date........: 07/09/1991
  1257. *-- Notes.......: Used to ask user for input of a number within a range
  1258. *--               based on gaming dice. Programmer supplies # of dice,
  1259. *--               and number of sides to function, it returns the input
  1260. *--               from the user (and only allows valid input).
  1261. *-- Written for.: dBASE IV, 1.1
  1262. *-- Rev. History: None
  1263. *-- Calls.......: SHADOW               (procedure in PROC.PRG)
  1264. *--               CENTER               (procedure in PROC.PRG)
  1265. *-- Called by...: Any
  1266. *-- Usage.......: ValiDice(<nNum>,<nDice>,"<cMessage>","<cColor>")
  1267. *-- Example.....: replace STRENGTH with ValiDice(3,6,"Strength",;
  1268. *--                                       "rg+/gb,w/n,rg+/gb")  && 3 6-sided
  1269. *-- Returns.....: Valid user input
  1270. *-- Parameters..: nNum     = Number of dice
  1271. *--               nSides   = Number of sides
  1272. *--               cMessage = Message for line 0
  1273. *--               cColor   = Colors for window
  1274. *--------------------------------------------------------------------------
  1275.  
  1276.     PARAMETERS nNum, nDice, cMessage, cColor
  1277.     
  1278.     save screen to sDice
  1279.     define window wDice from 8,20 to 14,60 double color &cColor
  1280.     do shadow with 8,20,14,60
  1281.     activate window wDice
  1282.     
  1283.     nUpper = nNum * nDice    && upper limit
  1284.     do center with 0,40,"","&cMessage"
  1285.     do center with 1,40,"","Enter a value from "+ltrim(str(nNum))+" to "+;
  1286.                             ltrim(str(nUpper))
  1287.     do center with 2,40,"","("+ltrim(str(nNum))+"d"+ltrim(str(nDice))+")"
  1288.     nUser = 0
  1289.     @4,18 get nUser picture "999" valid required nUser => nNum .and.;
  1290.                                                  nUser =< nUpper;
  1291.                              error chr(7)+"Enter a valid number!"
  1292.     read 
  1293.  
  1294.     deactivate window wDice
  1295.     release window wDice
  1296.     restore screen from sDice
  1297.     release screen sDice
  1298.     
  1299. RETURN nUser
  1300. *-- EoF: ValiDice
  1301.  
  1302. FUNCTION DiceChoose
  1303. *--------------------------------------------------------------------------
  1304. *-- Programmer..: Ken Mayer
  1305. *-- Date........: 07/09/1991
  1306. *-- Notes.......: This is another FRPG routine -- It is used to give the
  1307. *--               user a choice of three die roles. The computer will
  1308. *--               randomly generate a die roll three times so the user
  1309. *--               has a choice. It uses DICE (above) to do so.
  1310. *-- Written for.: dBASE IV, 1.1
  1311. *-- Rev. History: None
  1312. *-- Calls.......: MULTDICE()           (Function in PROC.PRG)
  1313. *--               DICE()               (Function in PROC.PRG)
  1314. *--               SHADOW               (Procedure in PROC.PRG)
  1315. *--               CENTER               (Procedure in PROC.PRG)
  1316. *-- Called by...: Any
  1317. *-- Usage.......: DiceChoose(<nNum>,<nSides>,"<nMessage>","<cColor>")
  1318. *-- Example.....: replace STRENGTH with DiceChoose(3,6,;
  1319. *--                                 "To determine your character's Strength",;
  1320. *--                                 "rg+/gb,w/n,rg+/gb")
  1321. *-- Returns.....: The value of one of the choices displayed for the user,
  1322. *--               which will be a value from nNum to nNum*nSides + nNum+nPlus.
  1323. *-- Parameters..: nNum     = number of dice to be rolled
  1324. *--               nSides   = number of sides for each dice
  1325. *--               cMessage = Message to be displayed at line 0 (max 40 Char)
  1326. *--               cColor   = Colors for the window
  1327. *--------------------------------------------------------------------------
  1328.  
  1329.     PARAMETERS nNum, nSides, cMessage, cColor
  1330.     
  1331.     *-- here we determine the three values for the user (roll the dice) --
  1332.     *-- The problem with using MULTDICE function above for all three values, is
  1333.     *-- that it calls DICE each time, which resets the random number table, 
  1334.     *-- and will give the exact same value for each of the three below. 
  1335.     *-- By copying the logic from MultDice() for the second two values, 
  1336.     *-- we only call DICE once, the values should all be random, instead of 
  1337.     *-- the same values (from the same random # table).
  1338.     
  1339.     *-- value 1 -- use MultDice above for this one
  1340.     nVal1 = MultDice(nNum,nSides)          && call MULTDICE and set RAND # Table
  1341.     
  1342.     *-- value 2 -- DON'T use MultDice, but use the same logic ...
  1343.     nVal2 = 0                              && init nVal2
  1344.     nCount = 0                             && set counter
  1345.     do while nCount < nNum                 && loop for number of dice 
  1346.         nNewVal = int(rand() * nSides) + 1  && get new random value
  1347.         nVal2 = nVal2 + nNewval             && add to total
  1348.         nCount = nCount + 1                 && increment counter
  1349.     enddo
  1350.     
  1351.     *-- value 3 -- same as value 2
  1352.     nVal3 = 0                              && init nVal3
  1353.     nCount = 0                             && set counter
  1354.     do while nCount < nNum                 && loop for number of dice 
  1355.         nNewVal = int(rand() * nSides) + 1  && get new random value
  1356.         nVal3 = nVal3 + nNewval             && add to total
  1357.         nCount = nCount + 1                 && increment counter
  1358.     enddo
  1359.     
  1360.     *-- now we have the three values we need, define windows/menu ...
  1361.     define window wDice from 8,20 to 17,60 double color &cColor
  1362.     save screen to sDice
  1363.     define menu mDice                      && as it says, define the menu
  1364.     define pad  pChoice1 of mDice prompt ltrim(str(nVal1)) at 3,18
  1365.     define pad  pChoice2 of mDice prompt ltrim(str(nVal2)) at 4,18
  1366.     define pad  pChoice3 of mDice prompt ltrim(str(nVal3)) at 5,18
  1367.     on selection pad pChoice1 of mDice deactivate menu
  1368.     on selection pad pChoice2 of mDice deactivate menu
  1369.     on selection pad pChoice3 of mDice deactivate menu
  1370.     
  1371.     *-- activate it all for user ...
  1372.     do shadow with 8,20,17,60              && display shadow
  1373.     activate window wDice                  && startup the window
  1374.     *-- display info in Window
  1375.     do center with 0,40,"","&cMessage"
  1376.     do center with 1,40,"","Choose a value from below:"
  1377.     @3,15 say "1)"
  1378.     @4,15 say "2)"
  1379.     @5,15 say "3)"
  1380.     do center with 7,40,"","Use Arrow keys, <Enter> to choose"
  1381.     activate menu mDice                    && startup menu
  1382.     
  1383.     do case                                && determine value to be returned
  1384.         case pad() = "PCHOICE1"
  1385.             nUser = nVal1
  1386.         case pad() = "PCHOICE2"
  1387.             nUser = nVal2
  1388.         case pad() = "PCHOICE3"
  1389.             nUser = nVal3
  1390.     endcase
  1391.     
  1392.     *-- cleanup
  1393.     release menu mDice
  1394.     deactivate window wDice
  1395.     release window wDice
  1396.     restore screen from sDice
  1397.     release screen sDice
  1398.     
  1399. RETURN nUser
  1400. *-- EoF: DiceChoose
  1401.  
  1402. *--------------------------------------------------------------------------
  1403. *-- These next two are ones I created for the SCA (Society for Creative
  1404. *-- Anachronism) -- they deal with SCA dates, which start at May 1, 1966.
  1405. *-- One goes from SCA dates to Real dates (i.e., 05/01/66 versus May 1, AS I)
  1406. *-- and the other goes back to SCA dates from real dates ...
  1407. *--------------------------------------------------------------------------
  1408.  
  1409. PROCEDURE SCA_Real
  1410. *--------------------------------------------------------------------------
  1411. *-- Programmer..: Ken Mayer (Hirsch von Henford)
  1412. *-- Date........: 07/23/1991
  1413. *-- Notes.......: This procedure was designed to handle data entered into
  1414. *--               the Order of Precedence of the Principality of the Mists.
  1415. *--               The problem is, my usual sources of data give only SCA
  1416. *--               dates, and in order to sort properly, I need real dates.
  1417. *--               This procedure will handle it, and goes hand-in-hand with
  1418. *--               the function Real_SCA, to translate real dates to SCA
  1419. *--               dates ... This procedure assumes that you have set the
  1420. *--               F1 Key (see Example below). If you use a different F key,
  1421. *--               you will want to modify the ON KEY LABEL commands ...
  1422. *-- Written for.: dBASE IV, 1.1
  1423. *-- Rev. History: 07/29/1991  -- modified it to stuff a character directly into
  1424. *--                    a date field (was having to do a CTOD in the program),
  1425. *--                    and added use of ESC to escape out, instead of killing
  1426. *--                    the procedure and the program calling it ...
  1427. *-- Calls.......: Center               (Procedure in PROC.PRG)
  1428. *--               Shadow               (Procedure in PROC.PRG)
  1429. *--               Arabic()             (Function in PROC.PRG)
  1430. *-- Called by...: Any
  1431. *-- Usage.......: do SCA_Real
  1432. *-- Example.....: on key label f1 do sca_real
  1433. *--               store {} to t_date   && initialize as a date
  1434. *--                                    && or you could STORE datefield to t_date
  1435. *--                                    && if you have a date field ...
  1436. *--               clear
  1437. *--               @5,10 say "Enter a date:" get t_date;
  1438. *--                  message "Press <F1> to convert from SCA date to real date"
  1439. *--               read
  1440. *--               on key label f1  && clear out that command ...
  1441. *-- Returns.....: real date, forced into field ...
  1442. *-- Parameters..: None
  1443. *--------------------------------------------------------------------------
  1444.     cEscape = set("ESCAPE")
  1445.     set escape off            && so we can handle the Escape Key
  1446.     cExact = set("EXACT")
  1447.     set exact on              && VERY important ...
  1448.     on key label F1 ?? chr(7) && make it beep, rather than call this procedure 
  1449.                               && again, which causes wierdnesses ...
  1450.     *-- first let's popup a window to ask for the information ...
  1451.     
  1452.     save screen to sDate
  1453.     define window wDate from 8,20 to 15,60 color rg+/gb,n/g,rg+/gb
  1454.     do shadow with 8,20,15,60
  1455.     activate window wDate
  1456.     
  1457.     *-- set the memvars ...
  1458.     cYear  = space(8)
  1459.     cMonth = space(3)
  1460.     cDay   = space(2)
  1461.     
  1462.     do center with 0,40,"","Enter SCA Date below:"
  1463.     do while .t.
  1464.         
  1465.         @2,14 say "Month: " get cMonth ;
  1466.             picture "@M JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC";
  1467.             message "Enter first letter of month, <Space> to scroll through, "+;
  1468.                 "<Enter> to choose" color rg+/gb,n/g
  1469.         @3,14 say "  Day: " get cDay picture "99";
  1470.             message "Enter 2 digits for day of the month, if blank will assume 15";
  1471.                 color rg+/gb,n/g
  1472.         @4,14 say " Year: " get cYear picture "!!!!!!!!" ;
  1473.             message "Enter year in AS roman numeral format";
  1474.             valid required len(trim(cYear)) > 0;
  1475.             error chr(7)+"This is no good without a year ..." color rg+/gb,n/g
  1476.     
  1477.         read
  1478.     
  1479.         if lastkey() = 27                && if user wants out by pressing <Esc>
  1480.             deactivate window wDate
  1481.             release window wDate
  1482.             restore screen from sDate
  1483.             release screen sDate
  1484.             set escape &cEscape
  1485.             set exact &cExact
  1486.             on key label F1 do SCA_Real   && reset it ...
  1487.             return
  1488.         endif
  1489.         
  1490.         if lastkey() < 0   && function key F1 through Shift F9 was pressed
  1491.             ?? chr(7)       && beep at user
  1492.             loop            && don't let 'em get away with that -- try again
  1493.         endif
  1494.         
  1495.         *-- check for valid roman numerals
  1496.         cYear = trim(cYear)    && trim it
  1497.         nYearLen = len(cYear)  && get length
  1498.         nCount = 0            
  1499.         do while nCount < nYearLen  && loop through length of year
  1500.             nCount = nCount + 1      && increment
  1501.             if .not. substr(cYear,nCount,1) $ "IVXLC" && if it's not here
  1502.                 do center with 5,40,"rg+/r","** ERROR -- Invalid Year **"
  1503.                 lError = .t.          && set error flag
  1504.                 exit                  && exit internal loop
  1505.             else
  1506.                 lError = .f.          && make sure this is false
  1507.             endif
  1508.         enddo     && end of internal loop
  1509.         if lError && if error,
  1510.             loop   && go back ...
  1511.         endif
  1512.         
  1513.         @5,0 clear   && clear out any error message ...
  1514.         do center with 5,40,"rg+/r","Converting Date ..."
  1515.         
  1516.         *-- First (and most important) is conversion of the year
  1517.         nYear = Arabic(cYear)
  1518.         
  1519.         *-- AS Years start at May ... if the month for a specific year is
  1520.         *-- Jan through April it's part of the next "real" year ...
  1521.         if cMonth = "JAN" .or. cMonth = "FEB" .or. cMonth = "MAR" .or.;
  1522.                                        cMonth = "APR"
  1523.             nYear = nYear + 1
  1524.         endif
  1525.         
  1526.         nYear = nYear + 65  && SCA dates start at 66 ...
  1527.         if nYear > 99       && this thing doesn't handle turn of the century
  1528.             @5,0 clear
  1529.             do center with 5,40,"rg+/r","No dates past XXXIV, please"
  1530.             loop
  1531.         endif
  1532.         
  1533.         *-- set numeric value of month ...
  1534.         do case
  1535.             case cMonth = "JAN"
  1536.                 nMonth = 1
  1537.             case cMonth = "FEB"
  1538.                 nMonth = 2
  1539.             case cMonth = "MAR"
  1540.                 nMonth = 3
  1541.             case cMonth = "APR"
  1542.                 nMonth = 4
  1543.             case cMonth = "MAY"
  1544.                 nMonth = 5
  1545.             case cMonth = "JUN"
  1546.                 nMonth = 6
  1547.             case cMonth = "JUL"
  1548.                 nMonth = 7
  1549.             case cMonth = "AUG"
  1550.                 nMonth = 8
  1551.             case cMonth = "SEP"
  1552.                 nMonth = 9
  1553.             case cMonth = "OCT"
  1554.                 nMonth = 10
  1555.             case cMonth = "NOV"
  1556.                 nMonth = 11
  1557.             case cMonth = "DEC"
  1558.                 nMonth = 12
  1559.         endcase
  1560.         
  1561.         *-- if the day field is empty, assume the middle of the month, so we
  1562.         *-- have SOMETHING to go by ...
  1563.         if len(alltrim(cDay)) = 0
  1564.             nDay = 15
  1565.         else
  1566.             nDay = val(cDay)
  1567.         endif
  1568.         
  1569.         *-- Check for valid day of the month ...
  1570.         if nDay > 29 .and. nMonth = 2 .or. (nDay = 31 .and. (nMonth = 4 .or.;
  1571.                                  nMonth = 6 .or. nMonth = 9 .or. nMonth = 11))
  1572.             do center with 5,40,"rg+/r",chr(7)+"INVALID DATE -- Try again ..."
  1573.             loop
  1574.         endif
  1575.         
  1576.         exit                        && out of loop -- if here, we're done
  1577.         
  1578.     enddo                          && end of loop
  1579.  
  1580.     *-- Convert it
  1581.     cDate = transform(nMonth,"@L 99")+transform(nDay,"@L 99")+;
  1582.               transform(nYear,"@L 99")
  1583.     
  1584.     *-- force this 'character' date into the date field on the screen ...
  1585.     keyboard cDate clear           && put it into the field, and clear out
  1586.                                    && keyboard buffer first ...
  1587.  
  1588.     *-- deal with cleanup ...
  1589.     deac wind wDate
  1590.     release wind wDate
  1591.     restore screen from sDate
  1592.     release screen sDate
  1593.     set escape &cEscape
  1594.     set exact &cExact
  1595.     on key label F1 do SCA_Real  && reset for user
  1596.     
  1597. RETURN
  1598. *-- EoP: SCA_Real
  1599.  
  1600. FUNCTION Real_SCA
  1601. *--------------------------------------------------------------------------
  1602. *-- Programmer..: Ken Mayer (Hirsch von Henford)
  1603. *-- Date........: 07/23/1991
  1604. *-- Notes.......: This procedure was designed to handle data entered into
  1605. *--               the Order of Precedence of the Principality of the Mists.
  1606. *--               For the purpose of printing the Order of Precedence, it 
  1607. *--               is necessary to convert real dates to SCA dates. I needed
  1608. *--               to store the data as real dates, but I want it to print with
  1609. *--               SCA dates ...
  1610. *-- Written for.: dBASE IV, 1.1
  1611. *-- Rev. History: None
  1612. *-- Calls.......: Roman()              (Function in PROC.PRG)
  1613. *-- Called by...: Any
  1614. *-- Usage.......: Real_SCA(<dDate>)
  1615. *-- Example.....: @nLine,25 say Real_SCA(CA)  && print SCA date for Corolla 
  1616. *--                                           &&   Aulica
  1617. *-- Returns.....: SCA Date based on dDate
  1618. *-- Parameters..: dDate = date to be converted
  1619. *--------------------------------------------------------------------------
  1620.  
  1621.     PARAMETERS dDate   && a real date, to be converted to an SCA date ...
  1622.     
  1623.     nYear  = year(dDate) - 1900        && remove the century
  1624.     nMonth = month(dDate)
  1625.     cMonth = substr(cmonth(dDate),1,3) && grab only first three characters
  1626.     cDay   = ltrim(str(day(dDate)))    && convert day to character
  1627.     
  1628.     *-- First (and most important) is conversion of the year
  1629.     *-- this is set to the turn of the century ... (AS XXXV)
  1630.     *-- AS Years start at May ... if the month for a specific year is
  1631.     *-- Jan through April it's part of the previous SCA year 
  1632.     *-- (April '67 = April AS I, not II)
  1633.      
  1634.     if nMonth < 5
  1635.         nYear = nYear - 1
  1636.     endif
  1637.     
  1638.     nYear = nYear - 65   && SCA dates start at 66
  1639.     cYear = Roman(nYear)
  1640.  
  1641. RETURN cMonth+" "+cDay+", "+"AS "+cYear
  1642. *-- EoF: Real_SCA
  1643.  
  1644. FUNCTION Roman
  1645. *-------------------------------------------------------------------------------
  1646. *-- Programmer..: Nick Carlin
  1647. *-- Date........: 04/13/1988
  1648. *-- Notes.......: A function designed to return a Roman Numeral based on
  1649. *--               an Arabic Numeral input ...
  1650. *-- Written for.: dBASE III+
  1651. *-- Rev. History: 07/25/1991 -- Modified by Ken Mayer for 1) dBASE IV, 1.1,
  1652. *--                             2) updated to a function, and 3) the procedure
  1653. *--                             GetRoman was done away with (combined into the
  1654. *--                             function).
  1655. *-- Calls.......: None
  1656. *-- Called by...: Any
  1657. *-- Usage.......: Roman(<nArabic>)
  1658. *-- Example.....: ? Roman(32)
  1659. *-- Returns.....: Roman Numeral (character string) equivalent of Arabic numeral
  1660. *--               passed to it. In example:  XXXII
  1661. *-- Parameters..: nArabic = Arabic number to be converted to Roman
  1662. *-------------------------------------------------------------------------------
  1663.  
  1664.     parameters nArabic
  1665.     private nCounter,nValue
  1666.     
  1667.     cRoman = ""                 && this is the returned value
  1668.     nCounter = 0                && init counter
  1669.     do while nCounter < 4       && loop four times, once for thousands, once
  1670.                                 && four hundreds, tens and singles ...
  1671.         nCounter = nCounter + 1  && increment counter
  1672.         do case                  && determine roman numerals to use
  1673.             case nCounter = 1     && first time through the loop
  1674.                 nDiv   = 1000      && divide by 1000
  1675.                 cSmall = "M"       && smallest value 
  1676.                 cMid   = "W"       && next up ...
  1677.                 cBig   = "Y"       && largest passed with this ... 10,000s
  1678.             case nCounter = 2
  1679.                 nDiv   = 100
  1680.                 cSmall = "C"
  1681.                 cMid   = "D"
  1682.                 cBig   = "M"
  1683.             case nCounter = 3
  1684.                 nDiv   = 10
  1685.                 cSmall = "X"
  1686.                 cMid   = "L"
  1687.                 cBig   = "C"
  1688.             case nCounter = 4
  1689.                 nDiv   = 1
  1690.                 cSmall = "I"
  1691.                 cMid   = "V"
  1692.                 cBig   = "X"
  1693.         endcase
  1694.         nValue = mod(int(nArabic/nDiv),10)
  1695.         do case
  1696.             case nValue = 0
  1697.                                 && do nothing
  1698.             case nValue = 1
  1699.                 cRoman = cRoman + cSmall                           && 1 = I
  1700.             case nValue = 2
  1701.                 cRoman = cRoman + cSmall + cSmall                  && 2 = II
  1702.             case nValue = 3
  1703.                 cRoman = cRoman + cSmall + cSmall + cSmall         && 3 = III
  1704.             case nValue = 4
  1705.                 cRoman = cRoman + cSmall + cMid                    && 4 = IV
  1706.             case nValue = 5
  1707.                 cRoman = cRoman + cMid                             && 5 = V
  1708.             case nValue = 6
  1709.                 cRoman = cRoman + cMid + cSmall                    && 6 = VI
  1710.             case nValue = 7
  1711.                 cRoman = cRoman + cMid + cSmall + cSmall           && 7 = VII
  1712.             case nValue = 8
  1713.                 cRoman = cRoman + cMid + cSmall + cSmall + cSmall  && 8 = VIII
  1714.             case nValue = 9
  1715.                 cRoman = cRoman + cSmall + cBig                    && 9 = IX
  1716.         endcase
  1717.         
  1718.     enddo  && while nCounter < 4
  1719.     
  1720. RETURN cRoman
  1721. *-- EoF: Roman()
  1722.  
  1723. FUNCTION Arabic
  1724. *-------------------------------------------------------------------------------
  1725. *-- Programmer..: Ken Mayer
  1726. *-- Date........: 07/25/1991
  1727. *-- Notes.......: This function converts a Roman Numeral to an arabic one.
  1728. *--               It parses the roman numeral into an array, and checks each 
  1729. *--               character ... if the previous character causes the value to 
  1730. *--               subtract (for example, IX = 9, not 10) we subtract that value, 
  1731. *--               and then set the previous value to 0, otherwise we would get 
  1732. *--               some odd values in return.
  1733. *--               So far, it works fine.
  1734. *-- Written for.: dBASE IV, 1.1
  1735. *-- Rev. History: ver. 1 07/25/1991
  1736. *-- Calls.......: None
  1737. *-- Called by...: Any
  1738. *-- Usage.......: Arabic(<cRoman>)
  1739. *-- Example.....: ?Arabic("XXIV")
  1740. *-- Returns.....: Arabic number (from example, 24)
  1741. *-- Parameters..: cRoman = character string containing roman numeral to be
  1742. *--               converted.
  1743. *-------------------------------------------------------------------------------
  1744.  
  1745.     parameters cRoman
  1746.     private nCounter
  1747.     
  1748.     cRoman = upper(cRoman)   && convert to all caps in case ...
  1749.     
  1750.     declare cChar[15],nNum[15] && hopefully no string will be sent that large ...
  1751.     
  1752.     nMax = 0                && counter for later on ..
  1753.     nCounter = 0            && parse cRoman into the array, one character per
  1754.     do while nCounter < 15  &&  array element ...
  1755.         nCounter = nCounter + 1
  1756.         if len(trim(substr(cRoman,nCounter,1))) > 0  && if something's there
  1757.             cChar[nCounter] = substr(cRoman,nCounter,1)
  1758.             nMax = nMax + 1   && set max times through NEXT loop
  1759.         else
  1760.             exit
  1761.         endif
  1762.     enddo
  1763.     
  1764.     *-- Now that it's in an array ... we need to look at it ... and convert
  1765.     *-- each character to an arabic number 
  1766.     nCounter = 0
  1767.     do while nCounter < nMax
  1768.         nCounter = nCounter + 1
  1769.         do case
  1770.             case cChar[nCounter] = "I"    && 1
  1771.                 nNum[nCounter] = 1
  1772.             case cChar[nCounter] = "V"    && 5
  1773.                 if nCounter > 1 .and. cChar[nCounter - 1] = "I"
  1774.                     nNum[nCounter] = 4      && IV = 4
  1775.                     nNum[nCounter - 1] = 0  && don't add anything later ...
  1776.                 else
  1777.                     nNum[nCounter] = 5      && otherwise we have 5
  1778.                 endif
  1779.             case cChar[nCounter] = "X"    && 10
  1780.                 if nCounter > 1 .and. cChar[nCounter - 1] = "I"
  1781.                     nNum[nCounter] = 9      && IX = 9
  1782.                     nNum[nCounter - 1] = 0  && same ... don't add this ...
  1783.                 else
  1784.                     nNum[nCounter] = 10     && X = 10
  1785.                 endif
  1786.             case cChar[nCounter] = "L"    && 50
  1787.                 if nCounter > 1 .and. cChar[nCounter - 1] = "X"
  1788.                     nNum[nCounter] = 40     && XL = 40
  1789.                     nNum[nCounter - 1] = 0
  1790.                 else
  1791.                     nNum[nCounter] = 50     && L = 50
  1792.                 endif
  1793.             case cChar[nCounter] = "C"    && 100
  1794.                 if nCounter > 1 .and. cChar[nCounter -1] = "X"
  1795.                     nNum[nCounter] = 90     && XC = 90
  1796.                     nNum[nCounter - 1] = 0
  1797.                 else
  1798.                     nNum[nCounter] = 100
  1799.                 endif
  1800.             case cChar[nCounter] = "D"    && 500
  1801.                 if nCounter > 1 .and. cChar[nCounter - 1] = "C"
  1802.                     nNum[nCounter] = 400    && CD = 400
  1803.                     nNum[nCounter - 1] = 0
  1804.                 else
  1805.                     nNum[nCounter] = 500
  1806.                 endif
  1807.             case cChar[nCounter] = "M"    && 1,000
  1808.                 if nCounter > 1 .and. cChar[nCounter - 1] = "C"
  1809.                     nNum[nCounter] = 900    && CM = 900
  1810.                     nNum[nCounter - 1] = 0
  1811.                 else
  1812.                     nNum[nCounter] = 1000
  1813.                 endif
  1814.             case cChar[nCounter] = "W"    && 5,000
  1815.                 if nCounter > 1 .and. cChar[nCounter - 1] = "M"
  1816.                     nNum[nCounter] = 4000   && MW = 4000
  1817.                     nNum[nCounter - 1] = 0
  1818.                 else
  1819.                     nNum[nCounter] = 5000
  1820.                 endif
  1821.             case cChar[nCounter] = "Y"    && 10,000
  1822.                 if nCounter > 1 .and. cChar[nCounter - 1] = "M"
  1823.                     nNum[nCounter] = 9000   && MY = 9000
  1824.                     nNum[nCounter - 1] = 0
  1825.                 else
  1826.                     nNum[nCounter] = 10000
  1827.                 endif
  1828.             && that's plenty big ...
  1829.         endcase
  1830.     enddo
  1831.  
  1832.     *-- Add it all together ... it SHOULD give us the proper arabic value
  1833.     nArabic = 0
  1834.     nCounter = 0
  1835.     do while nCounter < nMax
  1836.         nCounter = nCounter + 1
  1837.         nArabic = nArabic + nNum[nCounter]
  1838.     enddo
  1839.     
  1840. RETURN nArabic
  1841. *-- EoF: Arabic()
  1842.  
  1843. *-------------------------------------------------------------------------------
  1844. *-- End of Procedure File -- PROC.PRG
  1845. *-------------------------------------------------------------------------------
  1846.